home *** CD-ROM | disk | FTP | other *** search
/ PC World Interactive 7 / PC World Interactive 7.iso / program / pasprog.EXE / MUZIK.PAS < prev    next >
Pascal/Delphi Source File  |  1980-01-09  |  12KB  |  523 lines
  1.  
  2. Uses dos, graph, crt ;
  3.  
  4. Label xx;
  5.  
  6. Const
  7.   R  = 0; {Rest}
  8.   C  = 1;
  9.   Cs = 2;  Db = 2;
  10.   D  = 3;
  11.   Ds = 4;  Eb = 4;
  12.   E  = 5;
  13.   F  = 6;
  14.   Fs = 7;  Gb = 7;
  15.   G  = 8;
  16.   Gs = 9;  Ab = 9;
  17.   A  = 10;
  18.   As = 11; Bb = 11;
  19.   B  = 12;
  20.  
  21. Var
  22.   Oct_Val       : array[0..8] OF Real;
  23.   Freq_Val      : array[C..B] OF Real;
  24.   ust_tuslar    : string;
  25.   alt_tuslar    : string;
  26.   x,y,i,j       : integer;
  27.   kp            : char;
  28.   p             : pointer;
  29.   son           : integer;
  30.   s             : string;
  31.   okt,nota      : byte;
  32.   zaman,kes     : word;
  33.   oldint        : procedure;
  34.   lz,hz         : byte;
  35.   dosya         : text;
  36.   dosya_adi     : string;
  37.   Size          : Word;
  38.   oktev         : array[1..500] of byte;
  39.   notev         : array[1..500] of byte;
  40.   zamev         : array[1..500] of integer;
  41.  
  42.  
  43.  
  44. {F+}
  45. Procedure tik_tak;interrupt;
  46. begin
  47.   inc(zaman);
  48.   inline ($9C);
  49.   oldint;
  50. end;
  51. {F-}
  52.  
  53.  
  54. Procedure tus_bekle;
  55. begin
  56.   kp:=readkey;
  57. end;
  58.  
  59. Procedure curoff;
  60. var r:registers;
  61. begin
  62.   r.ah:=$1;r.cx:=$ffff;
  63.   intr($10,r);
  64. end;
  65.  
  66. Procedure Frekans_ayar;
  67. var
  68.   n : Byte;
  69. begin
  70.     Freq_Val[1] := 1;
  71.     FOR n := 2 TO 12 DO
  72.       Freq_Val[n] := Freq_Val[n - 1] * 1.0594630944;
  73.     Oct_Val[0] := 32.70319566;
  74.     FOR n := 1 TO 8 DO
  75.       Oct_Val[n] := Oct_Val[n - 1] * 2;
  76. end;
  77.  
  78. Procedure Nota_cal(oktav : Byte;
  79.                     nota : Byte;
  80.                      sure: Word);
  81. begin
  82.   IF nota = R then
  83.      NoSound
  84.      else
  85.       Sound(Round(Oct_Val[oktav] * Freq_Val[nota]));
  86.   Delay(sure);
  87.   NoSound;
  88. end;
  89.  
  90. Procedure calmaya_basla(Octave : Byte;
  91.                         Note   : Byte);
  92. begin
  93.   IF Note = R then NoSound
  94.      else Sound(Round(Oct_Val[Octave] * Freq_Val[Note]));
  95.     okt:=octave;
  96.     nota:=note;
  97. end;
  98.  
  99. Procedure txt(a,b,c:byte;s:string);
  100. begin
  101.   gotoxy(a,b);
  102.   textattr:=c;
  103.   write(s);
  104. end;
  105.  
  106.  
  107. Procedure ilk;
  108. begin
  109.   frekans_ayar;
  110.   nosound;
  111.  
  112.   for x:=1 to 4 do begin
  113.       for y:=1 to 12 do nota_cal(x,y,25);
  114.       end;
  115.  
  116.   nota_cal(4,12,500);
  117.   for x:=4 downto 1 do begin
  118.       for y:=12 downto 1 do nota_cal(x,y,25);
  119.       end;
  120. end;
  121.  
  122. Procedure grafik;
  123. var
  124.   grDriver : Integer;
  125.   grMode   : Integer;
  126.   ErrCode  : Integer;
  127. begin
  128.   grDriver := detect;
  129.   InitGraph(grDriver,grmode,'');
  130.   ErrCode := GraphResult;
  131.   if ErrCode <> grOk then
  132.   WriteLn('Graphics error:',
  133.   GraphErrorMsg(ErrCode));
  134. end;
  135.  
  136. Procedure nota_ciz(x,y,r:integer;renk:byte);
  137. var
  138.   size       : word;
  139.   eski_renk  : byte;
  140. begin
  141.   eski_renk:=getcolor;
  142.   setcolor(renk);
  143.   setfillstyle(solidfill,renk);
  144.   pieslice(x,y,0,360,r);
  145.   line(x+r,y,x+r,y-15);
  146.   arc(x+r,y-10,0,90,8);
  147.   arc(x+r,y-8,0,90,8);
  148. end;
  149.  
  150. Procedure pencere_kapat(x,y,z,t:integer);
  151. var a,b:integer;
  152. begin
  153.   setlinestyle(0,0,3);
  154.   setcolor(black);
  155.      a:=0;b:=0;
  156.      repeat
  157.           rectangle(x+a,y+b,z-a,t-b);
  158.           a:=a+2;
  159.           b:=b+2;
  160.      until (a>trunc((z-x)/2)) or (b>trunc((t-y)/2));
  161. end;
  162.  
  163. Procedure acilis;
  164. var x,y:integer;
  165. begin
  166.   grafik;
  167.   for x:=1 to 70 do
  168.   nota_ciz(random(getmaxx),random(getmaxy),5,random(getmaxcolor));
  169.   setlinestyle(0,0,1);
  170.   setcolor(red);
  171.   rectangle(0,0,getmaxx,getmaxy);
  172.   settextstyle(gothicfont,horizdir,7);
  173.   setfillstyle(solidfill,black);
  174. bar(trunc(getmaxx/5),trunc(getmaxy/5)+20,trunc(getmaxx/5)+400,trunc(getmaxy/5)
  175. +70);
  176.  
  177.   setcolor(darkgray);
  178.   for x:=1 to 5 do
  179.       outtextxy(trunc(getmaxx/5)+x,trunc(getmaxy/5)+x,'Müzik Editörü');
  180.   setcolor(lightgray);
  181.   outtextxy(trunc(getmaxx/5),trunc(getmaxy/5),'Müzik Editörü');
  182.  
  183.   setfillstyle(solidfill,red);
  184.   bar(20,310,620,327);
  185.   settextstyle(smallfont,horizdir,5);
  186.   setcolor(lightred);
  187.   outtextxy(32,312,'Bu Program Cenk TARHAN tarafindan Programlama Sanati eki için hazirlanmistir');
  188.   setcolor(white);
  189.   outtextxy(30,310,'Bu Program Cenk TARHAN tarafindan Programlama Sanati eki için hazirlanmistir');
  190.   ilk;
  191.   tus_bekle;
  192.   ilk;
  193.   pencere_kapat(0,0,getmaxx,getmaxy);
  194. end;
  195.  
  196. Procedure tus(x,y:integer;renk:byte);
  197. begin
  198.   setfillstyle(solidfill,renk);
  199.   bar(x,y,x+10,y+45);
  200.   setcolor(black);
  201.   rectangle(x-1,y-1,x+11,y+46);
  202. end;
  203.  
  204. Procedure editor_ekrani;
  205. begin
  206.   setlinestyle(0,0,1);
  207.   setcolor(red);
  208.   rectangle(0,0,getmaxx,getmaxy);
  209.   rectangle(0,0,getmaxx,trunc(getmaxy/20));
  210.   rectangle(0,0,getmaxx,trunc(getmaxy/10));
  211.   rectangle(0,getmaxy-25,getmaxx,getmaxy);
  212.   rectangle(0,getmaxy-50,getmaxx,getmaxy);
  213.  
  214.   setfillstyle(solidfill,blue);
  215.   floodfill(1,trunc(getmaxy/20-1),red);
  216.   floodfill(1,trunc(getmaxy-1),red);
  217.  
  218.   setfillstyle(solidfill,darkgray);
  219.   floodfill(1,trunc(getmaxy/10-1),red);
  220.   setcolor(white);
  221.   settextstyle(smallfont,horizdir,5);
  222.   outtextxy(270,0,'Müzik Editörü');
  223.   s:='Bu program Cenk Tarhan tarafindan Programlama Sanati eki icin'+
  224.   ' hazirlanmistir...';
  225.   outtextxy(30,getmaxy-20,s);
  226.   setcolor(lightred);
  227.   outtextxy(20,27,'Dosya     CAl      Basla      Kayit     Cikis');
  228.   setcolor(white);
  229.   outtextxy(20,27,' osya     C l       asla       ayit      ikis');
  230.  
  231.   outtextxy(540,27,'(F1) Yardim');
  232.   rectangle(50,260,590,270);
  233.   setfillstyle(solidfill,blue);
  234.   floodfill(51,261,white);
  235.   setfillstyle(solidfill,lightblue);
  236.   bar(40,270,600,320);
  237.  
  238.   x:=1;
  239.   repeat
  240.     tus(40+x*12,290,lightgray);
  241.     inc(x);
  242.   until x=46;
  243.   x:=1;
  244.   repeat
  245.     tus(45+x*12,275,darkgray);
  246.     tus(45+x*12+12,275,darkgray);
  247.         x:=x+7;
  248.   until x>50;
  249.   x:=1;
  250.   repeat
  251.     tus(82+x*12,275,darkgray);
  252.     tus(82+x*12+12,275,darkgray);
  253.     tus(82+x*12+24,275,darkgray);
  254.  
  255.     x:=x+7;
  256.   until x>40;
  257. end;
  258.  
  259. Procedure tus_kontrol;
  260. begin
  261.   kp:=readkey;
  262.   if kp=#32 then nosound;
  263.   for x:=1 to length(ust_tuslar) do begin
  264.       if upcase(kp)=ust_tuslar[x] then begin
  265.          if x<13 then calmaya_basla(2,x);
  266.          if x>=13 then calmaya_basla(3,x-12);
  267.          end;
  268.       end;
  269.   for x:=1 to length(alt_tuslar) do begin
  270.       if upcase(kp)=alt_tuslar[x] then begin
  271.          if x<6 then calmaya_basla(3,(x+7) mod 13);
  272.          if x>=6 then  calmaya_basla(4,(x-5) mod 13);
  273.          end;
  274.       end;
  275. end;
  276.  
  277. Procedure ana_menu(menu:byte);
  278. begin
  279.   setfillstyle(solidfill,darkgray);
  280.   bar(1,25,getmaxx-1,45);
  281.   case menu of
  282.     1 : begin
  283.          setfillstyle(solidfill,magenta);
  284.          bar(10,25,70,45);
  285.          end;
  286.     2 : begin
  287.          setfillstyle(solidfill,magenta);
  288.          bar(80,25,150,45);
  289.          end;
  290.     3 : begin
  291.          setfillstyle(solidfill,magenta);
  292.          bar(160,25,240,45);
  293.          end;
  294.     4 : begin
  295.          setfillstyle(solidfill,magenta);
  296.          bar(250,25,320,45);
  297.          end;
  298.     5 : begin
  299.          setfillstyle(solidfill,magenta);
  300.          bar(330,25,390,45);
  301.          end;
  302.     end;
  303.   setcolor(white);
  304.   settextstyle(smallfont,horizdir,5);
  305.  
  306.   setcolor(lightred);
  307.   outtextxy(20,27,'Dosya     CAl      Basla      Kayit     Cikis');
  308.   setcolor(white);
  309.   outtextxy(20,27,' osya     C l       asla       ayit      ikis');
  310.   outtextxy(540,27,'(F1) Yardim');
  311. end;
  312.  
  313. Procedure menu(x,y:integer; elemanlar:string);
  314. var
  315.   a,b,c,q: byte;
  316.   eleman:string;
  317. begin
  318.   b:=1;
  319.   for a:=1 to length(elemanlar) do if elemanlar[a]='|' then inc(b);
  320.   setfillstyle(solidfill,darkgray);
  321.   bar(x,y,x+70,y+b*18+15);
  322.   setcolor(lightred);
  323.   rectangle(x,y,x+70,y+b*18+15);
  324.   settextstyle(defaultfont,horizdir,1);
  325.   setcolor(white);
  326.   a:=1;
  327.   q:=0;
  328.   repeat
  329.     c:=1;
  330.     repeat
  331.       eleman[c]:=elemanlar[c+q];
  332.       inc(c);
  333.     until elemanlar[c+1]='|';
  334.     q:=q+c;
  335.     outtextxy(x+5,y+a*18-10,eleman);
  336.     inc(a);
  337.   until a=b;
  338.   tus_bekle;
  339.   setfillstyle(solidfill,black);
  340.   bar(x,y,x+70,y+b*18+15);
  341. end;
  342.  
  343. Procedure dosya_menusu;
  344. begin
  345.   ana_menu(1);
  346.   menu(20,50,'Yukle|Kaydet|Isim|');
  347. end;
  348.  
  349. Procedure calma_menusu;
  350. begin
  351.   bar(1,getmaxy-49,getmaxx-1,getmaxy-26);
  352.   setcolor(yellow);
  353.   outtextxy(60,getmaxy-49,'Su anda yapmis oldugunuz kayit calinmaktadir... Iyi eglenceler !');
  354.   ana_menu(2);
  355.   assign(dosya,dosya_adi);
  356.   reset(dosya);
  357.   readln(dosya,i);
  358.   for x:=1 to i do begin
  359.       readln(dosya,oktev[x]);
  360.       readln(dosya,notev[x]);
  361.       readln(dosya,zamev[x]);
  362.       end;
  363.  
  364.   close(dosya);
  365.  
  366.   zaman:=0;
  367.   for x:=1 to i-2 do begin
  368.       calmaya_basla(oktev[x],notev[x]);
  369.       delay(trunc(zamev[x+1]-zamev[x])*182);
  370.       end;
  371.   nosound;
  372. end;
  373.  
  374. Procedure basla_menusu;
  375. begin
  376.   bar(1,getmaxy-49,getmaxx-1,getmaxy-26);
  377.   setcolor(yellow);
  378.   outtextxy(30,getmaxy-49,'Klavyeyi kullanarak calabilirsiniz.. (standart Q klavye)        <ESC> bitirir');
  379.   ana_menu(3);
  380.   repeat
  381.   tus_kontrol;
  382.   until kp=#27;
  383.   nosound;
  384. end;
  385.  
  386. Procedure kayit_menusu;
  387. begin
  388.   bar(1,getmaxy-49,getmaxx-1,getmaxy-26);
  389.   setcolor(yellow);
  390.   outtextxy(30,getmaxy-49,'Kayit yapabilirsiniz. Kayitlariniz "DENEME.MUZ" adinda bir dosyaya yapilacak');
  391.   ana_menu(4);
  392.   setfillstyle(solidfill,lightgray);
  393.   bar(100,100,600,150);
  394.   setfillstyle(solidfill,lightred);
  395.   bar(100,130,600,150);
  396.   setcolor(yellow);
  397.   outtextxy(102,115,'Kayit basi');
  398.   outtextxy(522,115,'Kayit sonu');
  399.   zaman:=0;
  400.   setcolor(black);
  401.   outtextxy(222,115,'baslamak icin bir tusa basiniz');
  402.   tus_bekle;
  403.   setfillstyle(solidfill,lightgray);
  404.   bar(222,115,500,129);
  405.   outtextxy(230,115,'Kayittasiniz...     <ESC> durdur');
  406.   zaman:=0;
  407.   i:=1;
  408.   repeat
  409.     tus_kontrol;
  410.     oktev[i]:=okt;
  411.     notev[i]:=nota;
  412.     zamev[i]:=zaman;
  413.     inc(i);
  414.   until (kp=#27);
  415.   assign(dosya,dosya_adi);
  416.   rewrite(dosya);
  417.   writeln(dosya,i);
  418.   for x:=1 to i do begin
  419.       writeln(dosya,oktev[x]);
  420.       writeln(dosya,notev[x]);
  421.       writeln(dosya,zamev[x]);
  422.       end;
  423.   close(dosya);
  424.  
  425.   nosound;
  426.   setfillstyle(solidfill,lightgray);
  427.   bar(222,115,500,129);
  428.   outtextxy(330,115,'Kayit bitti...');
  429.   zaman:=0;
  430.   repeat
  431.   until zaman>20; {*Z*}
  432.   setfillstyle(solidfill,lightgray);
  433.   bar(222,115,500,129);
  434.   setfillstyle(solidfill,black);
  435.   pencere_kapat(100,100,600,150);
  436. end;
  437.  
  438. Procedure cikis_menusu;
  439. begin
  440.   bar(1,getmaxy-49,getmaxx-1,getmaxy-26);
  441.   setcolor(yellow);
  442.   outtextxy(30,getmaxy-49,'Programdan cikmak icin <E> programa devam etmek icin <H> tusuna basiniz...');
  443.   ana_menu(5);
  444.   rectangle(200,120,420,145);
  445.   outtextxy(220,125,'Programdan Cikis ? (E/H)');
  446.   setcolor(lightgray);
  447.   outtextxy(221,126,'Programdan Cikis ? (E/H)');
  448.   tus_bekle;
  449.   if upcase(kp)='E' then begin
  450.      pencere_kapat(0,0,getmaxx,getmaxy);
  451.      closegraph;
  452.      setintvec($8,@oldint);
  453.      clrscr;
  454.      writeln('Programimi kullandiginiz icin tesekkurler...');
  455.      halt;
  456.     end else begin
  457.      setfillstyle(solidfill,black);
  458.      bar(200,120,420,145);
  459.      end;
  460. end;
  461.  
  462. Procedure yardim(x,y,z,q:integer);
  463. begin
  464.   size:=imagesize(x,y,z,q);
  465.   getmem(p,size);
  466.   getimage(x,y,z,q,p^);
  467.   setcolor(white);
  468.   rectangle(x,y,z,q);
  469.   setcolor(lightgray);
  470.   rectangle(x,y,z-1,q-1);
  471.   setfillstyle(solidfill,darkgray);
  472.   bar(x,y,z-2,q-2);
  473.   setcolor(lightgreen);
  474.   settextstyle(defaultfont,horizdir,1);
  475.   outtextxy(x+10,y+20,'Yardim menusu henuz hazir degil!');
  476.   tus_bekle;
  477.   putimage(x,y,p^,normalput);
  478. end;
  479.  
  480. Procedure islem_secimi;
  481. begin
  482.   repeat;
  483.     setfillstyle(solidfill,black);
  484.     bar(1,getmaxy-49,getmaxx-1,getmaxy-26);
  485.     setcolor(yellow);
  486.     outtextxy(150,getmaxy-49,'Menu seceneklerinden birini tercih ediniz...');
  487.  
  488.     kp:=readkey;
  489.     case upcase(kp) of
  490.        'D' : dosya_menusu;
  491.        'A' : calma_menusu;
  492.        'B' : basla_menusu;
  493.        'K' : kayit_menusu;
  494.        'C' : cikis_menusu;
  495.        #59 : yardim(200,100,500,150);
  496.        end;
  497.  
  498.     ana_menu(0);
  499.   until 1=2;
  500. end;
  501.  
  502. { ANA PROGRAM BURADA BASLIYOR }
  503.  
  504. BEGIN
  505.   getintvec($8,@oldint);
  506.   setintvec($8,@tik_tak);
  507.  
  508.   dosya_adi:='deneme.muz';
  509.   nosound;
  510.   ust_tuslar := 'Q2W3ER5T6Y7UI9O0P[=';
  511.   alt_tuslar := 'ZSXDCVGBHNMK,L.;/';
  512.   frekans_ayar;
  513.   grafik;
  514.   randomize;
  515.   acilis;
  516.   editor_ekrani;
  517.   islem_secimi;
  518.   pencere_kapat(0,0,getmaxx,getmaxy);
  519.   closegraph;
  520.   setintvec($8,@oldint);
  521.   clrscr;
  522.   writeln('Programimi kullandiginiz icin tesekkurler...');
  523. END.